home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / XLISP.LZH / XLISPSRC.ARC / XLISP.H < prev    next >
Text File  |  1986-05-26  |  10KB  |  336 lines
  1. /* xlisp - a small subset of lisp */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. /* system specific definitions */
  7. #define AZTEC_LM
  8.  
  9. #include <stdio.h>
  10. #include <ctype.h>
  11. #ifndef MEGAMAX
  12. #include <setjmp.h>
  13. #endif
  14.  
  15. /* NNODES    number of nodes to allocate in each request (1000) */
  16. /* TDEPTH    trace stack depth (500) */
  17. /* EDEPTH    evaluation stack depth (2000) */
  18. /* FORWARD    type of a forward declaration () */
  19. /* LOCAL    type of a local function (static) */
  20. /* AFMT        printf format for addresses ("%x") */
  21. /* FIXNUM    data type for fixed point numbers (long) */
  22. /* ITYPE    fixed point input conversion routine type (long atol()) */
  23. /* ICNV        fixed point input conversion routine (atol) */
  24. /* IFMT        printf format for fixed point numbers ("%ld") */
  25. /* FLONUM    data type for floating point numbers (float) */
  26. /* SYSTEM    enable the control-d command */
  27.  
  28. /* for the MegaMax compiler */
  29. #ifdef MEGAMAX
  30. #define LOCAL
  31. #define AFMT        "%lx"
  32. #endif
  33.  
  34. /* for the AZTEC C compiler - small model */
  35. #ifdef AZTEC_SM
  36. #define SYSTEM
  37. #define NIL        (void *)0
  38. #endif
  39.  
  40. /* for the AZTEC C compiler - large model */
  41. #ifdef AZTEC_LM
  42. #define SYSTEM
  43. #define NNODES        2000
  44. #define AFMT        "%lx"
  45. #define FLONUM        double
  46. #define NIL        (void *)0
  47. #endif
  48.  
  49. /* for the Digital Research C compiler (Atari ST) */
  50. #ifdef DR
  51. #define LOCAL
  52. #define AFMT        "%lx"
  53. #define FLONUM        double
  54. #undef NULL
  55. #define NULL        0L
  56. #endif
  57.  
  58. /* default important definitions */
  59. #ifndef NNODES
  60. #define NNODES        1000
  61. #endif
  62. #ifndef TDEPTH
  63. #define TDEPTH        500
  64. #endif
  65. #ifndef EDEPTH
  66. #define EDEPTH        2000
  67. #endif
  68. #ifndef FORWARD
  69. #define FORWARD
  70. #endif
  71. #ifndef LOCAL
  72. #define LOCAL        static
  73. #endif
  74. #ifndef AFMT
  75. #define AFMT        "%x"
  76. #endif
  77. #ifndef FIXNUM
  78. #define FIXNUM        long
  79. #endif
  80. #ifndef ITYPE
  81. #define ITYPE        long atol()
  82. #endif
  83. #ifndef ICNV
  84. #define ICNV(n)        atol(n)
  85. #endif
  86. #ifndef IFMT
  87. #define IFMT        "%ld"
  88. #endif
  89. #ifndef FLONUM
  90. #define FLONUM        float
  91. #endif
  92.  
  93. /* useful definitions */
  94. #define TRUE    1
  95. #define FALSE    0
  96. #ifndef NIL
  97. #define NIL    (NODE *)0
  98. #endif
  99.  
  100. /* program limits */
  101. #define STRMAX        100        /* maximum length of a string constant */
  102. #define HSIZE        199        /* symbol hash table size */
  103. #define SAMPLE        100        /* control character sample rate */
  104.     
  105. /* node types */
  106. #define FREE    0
  107. #define SUBR    1
  108. #define FSUBR    2
  109. #define LIST    3
  110. #define SYM    4
  111. #define INT    5
  112. #define STR    6
  113. #define OBJ    7
  114. #define FPTR    8
  115. #define FLOAT    9
  116. #define VECT    10
  117.  
  118. /* node flags */
  119. #define MARK    1
  120. #define LEFT    2
  121.  
  122. /* string types */
  123. #define DYNAMIC    0
  124. #define STATIC    1
  125.  
  126. /* new node access macros */
  127. #define ntype(x)    ((x)->n_type)
  128.  
  129. /* macros to protect node pointers */
  130. #define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
  131. #define xlsave(n)    {*--xlstack = &n; n = NIL;}
  132. #define xlprotect(n)    {*--xlstack = &n;}
  133.  
  134. /* check the stack and protect a single pointer */
  135. #define xlsave1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  136.                          *--xlstack = &n; n = NIL;}
  137.  
  138. /* type predicates */
  139. #define atom(x)        ((x) == NIL || (x)->n_type != LIST)
  140. #define null(x)        ((x) == NIL)
  141. #define listp(x)    ((x) == NIL || (x)->n_type == LIST)
  142. #define consp(x)    ((x) && (x)->n_type == LIST)
  143. #define subrp(x)    ((x) && (x)->n_type == SUBR)
  144. #define fsubrp(x)    ((x) && (x)->n_type == FSUBR)
  145. #define stringp(x)    ((x) && (x)->n_type == STR)
  146. #define symbolp(x)    ((x) && (x)->n_type == SYM)
  147. #define filep(x)    ((x) && (x)->n_type == FPTR)
  148. #define objectp(x)    ((x) && (x)->n_type == OBJ)
  149. #define fixp(x)        ((x) && (x)->n_type == INT)
  150. #define floatp(x)    ((x) && (x)->n_type == FLOAT)
  151. #define vectorp(x)    ((x) && (x)->n_type == VECT)
  152.  
  153. /* cons access macros */
  154. #define car(x)        ((x)->n_car)
  155. #define cdr(x)        ((x)->n_cdr)
  156. #define consa(x)    cons(x,NIL)
  157. #define consd(x)    cons(NIL,x)
  158. #define rplaca(x,y)    ((x)->n_car = (y))
  159. #define rplacd(x,y)    ((x)->n_cdr = (y))
  160.  
  161. /* symbol access macros */
  162. #define getvalue(x)    ((x)->n_symvalue)
  163. #define setvalue(x,v)    ((x)->n_symvalue = (v))
  164. #define getplist(x)    ((x)->n_symplist->n_cdr)
  165. #define setplist(x,v)    ((x)->n_symplist->n_cdr = (v))
  166. #define getpname(x)    ((x)->n_symplist->n_car)
  167.  
  168. /* vector access macros */
  169. #define getsize(x)    ((x)->n_vsize)
  170. #define getelement(x,i)    ((x)->n_vdata[i])
  171. #define setelement(x,i,v) ((x)->n_vdata[i] = (v))
  172.  
  173. /* object access macros */
  174. #define getclass(x)    ((x)->n_vdata[0])
  175. #define getivar(x,i)    ((x)->n_vdata[i+1])
  176. #define setivar(x,i,v)    ((x)->n_vdata[i+1] = (v))
  177.  
  178. /* subr/fsubr access macros */
  179. #define getsubr(x)    ((x)->n_subr)
  180.  
  181. /* fixnum/flonum access macros */
  182. #define getfixnum(x)    ((x)->n_int)
  183. #define getflonum(x)    ((x)->n_float)
  184.  
  185. /* string access macros */
  186. #define getstring(x)    ((x)->n_str)
  187. #define setstring(x,v)    ((x)->n_str = (v))
  188.  
  189. /* file access macros */
  190. #define getfile(x)    ((x)->n_fp)
  191. #define setfile(x,v)    ((x)->n_fp = (v))
  192. #define getsavech(x)    ((x)->n_savech)
  193. #define setsavech(x,v)    ((x)->n_savech = (v))
  194.  
  195. /* macro to check for the end of the argument list */
  196. #define xllastarg(args)    if (args) xltoomany(args)
  197.  
  198. /* symbol node */
  199. #define n_symplist    n_info.n_xsym.xsy_plist
  200. #define n_symvalue    n_info.n_xsym.xsy_value
  201.  
  202. /* subr/fsubr node */
  203. #define n_subr        n_info.n_xsubr.xsu_subr
  204.  
  205. /* list node */
  206. #define n_car        n_info.n_xlist.xl_car
  207. #define n_cdr        n_info.n_xlist.xl_cdr
  208.  
  209. /* integer node */
  210. #define n_int        n_info.n_xint.xi_int
  211.  
  212. /* float node */
  213. #define n_float        n_info.n_xfloat.xf_float
  214.  
  215. /* string node */
  216. #define n_str        n_info.n_xstr.xst_str
  217. #define n_strtype    n_info.n_xstr.xst_type
  218.  
  219. /* file pointer node */
  220. #define n_fp        n_info.n_xfptr.xf_fp
  221. #define n_savech    n_info.n_xfptr.xf_savech
  222.  
  223. /* vector/object node */
  224. #define n_vsize        n_info.n_xvect.xv_size
  225. #define n_vdata        n_info.n_xvect.xv_data
  226.  
  227. /* node structure */
  228. typedef struct node {
  229.     char n_type;        /* type of node */
  230.     char n_flags;        /* flag bits */
  231.     union {            /* value */
  232.     struct xsym {        /* symbol node */
  233.         struct node *xsy_plist;    /* symbol plist - (name . plist) */
  234.         struct node *xsy_value;    /* the current value */
  235.     } n_xsym;
  236.     struct xsubr {        /* subr/fsubr node */
  237.         struct node *(*xsu_subr)();    /* pointer to an internal routine */
  238.     } n_xsubr;
  239.     struct xlist {        /* list node (cons) */
  240.         struct node *xl_car;    /* the car pointer */
  241.         struct node *xl_cdr;    /* the cdr pointer */
  242.     } n_xlist;
  243.     struct xint {        /* integer node */
  244.         FIXNUM xi_int;        /* integer value */
  245.     } n_xint;
  246.     struct xfloat {        /* float node */
  247.         FLONUM xf_float;        /* float value */
  248.     } n_xfloat;
  249.     struct xstr {        /* string node */
  250.         int xst_type;        /* string type */
  251.         char *xst_str;        /* string pointer */
  252.     } n_xstr;
  253.     struct xfptr {        /* file pointer node */
  254.         FILE *xf_fp;        /* the file pointer */
  255.         int xf_savech;        /* lookahead character for input files */
  256.     } n_xfptr;
  257.     struct xvect {        /* vector node */
  258.         int xv_size;        /* vector size */
  259.         struct node **xv_data;    /* vector data */
  260.     } n_xvect;
  261.     } n_info;
  262. } NODE;
  263.  
  264. /* execution context flags */
  265. #define CF_GO        1
  266. #define CF_RETURN    2
  267. #define CF_THROW    4
  268. #define CF_ERROR    8
  269. #define CF_CLEANUP    16
  270. #define CF_CONTINUE    32
  271. #define CF_TOPLEVEL    64
  272.  
  273. /* execution context */
  274. typedef struct context {
  275.     int c_flags;            /* context type flags */
  276.     struct node *c_expr;        /* expression (type dependant) */
  277.     jmp_buf c_jmpbuf;            /* longjmp context */
  278.     struct context *c_xlcontext;    /* old value of xlcontext */
  279.     struct node ***c_xlstack;        /* old value of xlstack */
  280.     struct node *c_xlenv;        /* old value of xlenv */
  281.     int c_xltrace;            /* old value of xltrace */
  282. } CONTEXT;
  283.  
  284. /* function table entry structure */
  285. struct fdef {
  286.     char *f_name;            /* function name */
  287.     int f_type;                /* function type SUBR/FSUBR */
  288.     struct node *(*f_fcn)();        /* function code */
  289. };
  290.  
  291. /* memory segment structure definition */
  292. struct segment {
  293.     int sg_size;
  294.     struct segment *sg_next;
  295.     struct node sg_nodes[1];
  296. };
  297.  
  298. /* external variables */
  299. extern struct node ***xlstktop;        /* top of the evaluation stack */
  300. extern struct node ***xlstkbase;    /* base of the evaluation stack */
  301. extern struct node ***xlstack;        /* evaluation stack pointer */
  302.  
  303. /* external procedure declarations */
  304. extern struct node *xleval();        /* evaluate an expression */
  305. extern struct node *xlapply();        /* apply a function to arguments */
  306. extern struct node *xlevlist();        /* evaluate a list of arguments */
  307. extern struct node *xlarg();        /* fetch an argument */
  308. extern struct node *xlevarg();        /* fetch and evaluate an argument */
  309. extern struct node *xlmatch();        /* fetch an typed argument */
  310. extern struct node *xlevmatch();    /* fetch and evaluate a typed arg */
  311. extern struct node *xlgetfile();    /* fetch a file/stream argument */
  312. extern struct node *xlsend();        /* send a message to an object */
  313. extern struct node *xlenter();        /* enter a symbol */
  314. extern struct node *xlsenter();        /* enter a symbol with a static pname */
  315. extern struct node *xlmakesym();    /* make an uninterned symbol */
  316. extern struct node *xlframe();        /* establish a new environment frame */
  317. extern struct node *xlgetvalue();    /* get value of a symbol */
  318.  
  319. extern struct node *cons();        /* (cons x y) */
  320.  
  321. extern struct node *cvsymbol();        /* convert a string to a symbol */
  322. extern struct node *cvcsymbol();    /* (same but constant string) */
  323. extern struct node *cvstring();        /* convert a string */
  324. extern struct node *cvcstring();    /* (same but constant string) */
  325. extern struct node *cvfile();        /* convert a FILE * to a file */
  326. extern struct node *cvsubr();        /* convert a function to a subr/fsubr */
  327. extern struct node *cvfixnum();        /* convert a fixnum */
  328. extern struct node *cvflonum();        /* convert a flonum */
  329.  
  330. extern struct node *newstring();    /* create a new string */
  331. extern struct node *newvector();    /* create a new vector */
  332. extern struct node *newobject();    /* create a new object */
  333.  
  334. extern struct node *xlgetprop();    /* get the value of a property */
  335.  
  336.